Language/OS - Multiplatform Resource Library

home *** CD-ROM | disk | FTP | other *** search

/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / table.lisp < prev next >

Wrap

Text File | 1991-07-16 | 61.8 KB | 1,639 lines

;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*- ;;;----------------------------------------------------------------------------------+ ;;; | ;;; TEXAS INSTRUMENTS INCORPORATED | ;;; P.O. BOX 149149 | ;;; AUSTIN, TEXAS 78714 | ;;; | ;;; Copyright (C) 1989, 1990 Texas Instruments Incorporated. | ;;; | ;;; Permission is granted to any individual or institution to use, copy, modify, and | ;;; distribute this software, provided that this complete copyright and permission | ;;; notice is maintained, intact, in all copies and supporting documentation. | ;;; | ;;; Texas Instruments Incorporated provides this software "as is" without express or | ;;; implied warranty. | ;;; | ;;;----------------------------------------------------------------------------------+ (in-package "CLIO-OPEN") (export '( table make-table table-column-alignment table-column-width table-columns table-delete-policy table-layout-size-policy table-member table-row-alignment table-row-height table-same-height-in-row table-same-width-in-column table-separator table-row table-column ) 'clio-open) ;;; ;;; Call-Tree... ;;; ;;; Preferred-Size (Table) ;;; . check-for-existing-wis ;;; . place-children-physically ;;; . . put-kids-into-maximum-unaligned-columns ;;; . . . find-first-parents-width ;;; . . . assign-kids-to-rows-and-columns ;;; . . . preferred-size (child) ;;; . . . move (child) ;;; . . . resize (child) ;;; . . put-kids-into-maximum-aligned-columns ;;; . . . assign-kids-to-rows-and-columns ;;; . . . . assign-a-kid-to-a-row-and-column ;;; . . . . build-sorted-list-of-children ;;; . . . get-maximum-possible-ncolumns ;;; . . . . preferred-size (child) ;;; . . . preferred-size (child) ;;; . . . adjust-column-widths-so-child-fits ;;; . . put-kids-into-specified-number-of-columns ;;; . . . assign-kids-to-rows-and-columns ;;; . . . preferred-size (child) ;;; . . scan-for-largest-children ;;; . . . preferred-size (child) ;;; . . determine-a-rows-height ;;; . . preferred-size (child) ;;; . . move (child) ;;; . . resize (child) ;;; . . calculate-preferred-height ;;; . . determine-a-rows-height ;;; . . . preferred-size (child) ;;; . . calculate-preferred-width ;;; . ;;; Change-Layout(Table) ;;; . check-for-existing-wis ;;; . place-children-physically ;;; . change-geometry (Table) ;;; . ;;; Resize :after (Table) ;;; . change-layout (Table) ;;; . ;;; Manage-Geometry (Table) ;;; . Change-Geometry (Table) ;;; Basic Organization and Flow: ;;; The Table contact lays out its children per the values of its policy resources and the ;;; row/column constraints of its children, with the resource values always taking precedence ;;; over the children's constraint values. ;;; ;;; The function place-children-physically does the real work of Table. ;;; ;;; The differences in Table's logical flow for the possible values for the :columns resource ;;; are embodied primarily in the three routines ;;; ;;; put-kids-into-maximum-unaligned-columns ;;; put-kids-into-maximum-aligned-columns ;;; put-kids-into-specified-number-of-columns ;;; ;;; There are 5 ways into the Table contact's logic: ;;; ;;; Preferred-Size (Table) ;;; Change-Layout (Table) ;;; Resize :after (Table) ;;; Manage-Geometry (Table) ;;; (SETF layout-policy-resource) ;;; ;;; =========================================================================== ;;; T h e T A B L E L a y o u t C o n t a c t ;;; =========================================================================== (DEFCONTACT table (gravity-mixin spacing-mixin core composite) ((column-alignment :type (MEMBER :left :center :right) :reader table-column-alignment ; SETF method defined below. :initarg :column-alignment :initform :left) (column-width :type (OR (MEMBER :maximum) cons (integer 1 *)) :reader table-column-width ; SETF method defined below. :initarg :column-width :initform :maximum) (columns :type (OR (integer 1 *) (MEMBER :maximum :none)) :reader table-columns ; SETF method defined below. :initarg :columns :initform :maximum) (delete-policy :type (MEMBER :shrink-list :shrink-column :shrink-none :shrink-row) :reader table-delete-policy ; SETF method defined below. :initarg :delete-policy :initform :shrink-none) (layout-size-policy :type (MEMBER :maximum :minimum :none) :reader table-layout-size-policy ; SETF method defined below. :initarg layout-size-policy :initform :maximum) (row-height :type (OR (MEMBER :maximum) cons (integer 1 *)) :reader table-row-height ; SETF method defined below. :initarg :row-height :initform :maximum) (row-alignment :type (MEMBER :top :center :bottom) :reader table-row-alignment ; SETF method defined below. :initarg :row-alignment :initform :bottom) (same-height-in-row :type (MEMBER :on :off) :reader table-same-height-in-row ; SETF method defined below. :initarg :same-height-in-row :initform :off) (same-width-in-column :type (MEMBER :on :off) :reader table-same-width-in-column ; SETF method defined below. :initarg :same-width-in-column :initform :off) (separators :type list :initarg :separators :initform nil)) (:resources (border-width :initform 0) column-alignment column-width columns delete-policy layout-size-policy row-alignment row-height same-height-in-row same-width-in-column separators) (:constraints (row :type (integer 0 *)) (column :type (integer 0 *))) (:documentation "Arranges its children in an array of rows and columns." )) (DEFUN make-table (&rest initargs &key &allow-other-keys) (APPLY #'make-contact 'table initargs)) ;;; =========================================================================== ;;; ;;; ORG-ENTRY: the entries on the what-if-organization list ;;; ;;; =========================================================================== ;;; (DEFSTRUCT (org-entry :named (:type vector) (:conc-name "ORG-ENTRY-")) kid row column width height border-width) (DEFUN establish-org-entry (kid row column) (MULTIPLE-VALUE-BIND (p-w p-h p-b-w) (preferred-size kid) (make-org-entry :kid kid :row row :column column :width p-w :height p-h :border-width p-b-w))) ;;; =========================================================================== ;;; ;;; What-if Structures and Their management ;;; ;;; =========================================================================== ;;; ;;; ;;; Structures of this kind are placed on the Table's plist under the :what-if-structures ;;; property to record already-performed preferred-size calculations for the current set of ;;; policy resource values but different widths/heights. Any change to a policy resource ;;; destroys this cache of what-if structures, as does a call to change-layout. ;;; ;;; Hmmmm... We must keep the children's sizes here, have all the layout logic look here ;;; rather than at the kids' preferred-size methods. Where to keep this info? In organization ;;; (which is already a list of the kids) or in another list of kids, widths, heights, and ;;; border-widths. Or in an array... (DEFSTRUCT (what-if-structure :named (:type vector) (:conc-name "WHAT-IF-")) width height border-width organization ; org-entrys for :mapped children only! column-widths nrows ncolumns (preferred-width 0) (preferred-height 0) in-use ) (DEFUN check-for-existing-wis (table width height border-width &optional dont-create-p) ;; Returns the first (newest) wis found with width/height. ;; If no wis satisfying width/height exists, create a new one unless DONT-CREATE-P ;; is true, in which case return NIL. (DECLARE (VALUES (OR what-if-structure NULL))) (LET ((old-wis-list (GETF (window-plist table) :what-if-structures)) wis) (SETF wis (FIND-IF #'(lambda (wis) (AND (EQL (what-if-width wis) width) (EQL (what-if-height wis) height) (EQL (what-if-border-width wis) border-width))) old-wis-list)) (UNLESS (OR wis dont-create-p) (SETF (GETF (window-plist table) :what-if-structures) (PUSH (SETF wis (make-what-if-structure :width width :height height :border-width border-width :preferred-width 0 :preferred-height 0)) old-wis-list)) ) wis)) ;;; =========================================================================== ;;; ;;; A Table's Constraint's Accessors ;;; ;;; =========================================================================== ;;; (defun table-row (member) (declare (values (or null (integer 0 *)))) (contact-constraint member :row)) (defsetf table-row setf-table-row) (defun setf-table-row (member row) (check-type row (or null (integer 0 *))) (setf (contact-constraint member :row) row)) (defun table-column (member) (declare (values (or null (integer 0 *)))) (contact-constraint member :column)) (defsetf table-column setf-table-column) (defun setf-table-column (member column) (check-type column (or null (integer 0 *))) (setf (contact-constraint member :column) column)) ;;; =========================================================================== ;;; ;;; SETF functions for a Table's Resources ;;; ;;; =========================================================================== ;;; (defmethod (setf display-left-margin) :after (new-value (table table)) (declare (ignore new-value)) (change-layout table)) (defmethod (setf display-right-margin) :after (new-value (table table)) (declare (ignore new-value)) (change-layout table)) (defmethod (setf display-top-margin) :after (new-value (table table)) (declare (ignore new-value)) (change-layout table)) (defmethod (setf display-bottom-margin) :after (new-value (table table)) (declare (ignore new-value)) (change-layout table)) (defun force-relayout (table) (SETF (GETF (window-plist table) :what-if-structures) nil) (change-layout table)) (DEFMETHOD (SETF display-horizontal-space) :after (new-value (table table)) (DECLARE (IGNORE new-value)) (force-relayout table)) (DEFMETHOD (SETF table-column-alignment) (new-value (table table)) (with-slots (column-alignment) table (SETF column-alignment new-value) (force-relayout table) new-value)) (DEFMETHOD (SETF table-column-width) (new-value (table table)) (with-slots (column-width) table (SETF column-width new-value) (force-relayout table) new-value)) (DEFMETHOD (SETF table-columns) (new-value (table table)) (with-slots (columns) table (SETF columns new-value) (DOLIST (kid (composite-children table)) (SETF (table-column kid) nil (table-row kid) nil)) (force-relayout table) new-value)) (DEFMETHOD (SETF table-delete-policy) (new-value (table table)) (with-slots (delete-policy) table (SETF delete-policy new-value) (force-relayout table) new-value)) (DEFMETHOD (SETF table-layout-size-policy) (new-value (table table)) (with-slots (layout-size-policy) table (SETF layout-size-policy new-value) (force-relayout table) new-value)) (DEFMETHOD (SETF table-row-height) (new-value (table table)) (with-slots (row-height) table (SETF row-height new-value) (force-relayout table) new-value)) (DEFMETHOD (SETF table-row-alignment) (new-value (table table)) (with-slots (row-alignment) table (SETF row-alignment new-value) (force-relayout table) new-value)) (DEFMETHOD (SETF table-same-width-in-column) (new-value (table table)) (CHECK-TYPE new-value (MEMBER :on :off)) (with-slots (same-width-in-column) table (SETF same-width-in-column new-value) (force-relayout table) new-value)) (DEFMETHOD (SETF table-same-height-in-row) (new-value (table table)) (CHECK-TYPE new-value (MEMBER :on :off)) (with-slots (same-height-in-row) table (SETF same-height-in-row new-value) (force-relayout table) new-value)) ;;; =========================================================================== ;;; ;;; A Table's Separator Methods ;;; ;;; =========================================================================== ;;; ;;; Note: The physical size of an OL UI separator (white-space) will be defined ;;; to be half the height of the row it follows. (DEFMETHOD table-separator ((table table) row-number) (DECLARE (type integer row-number) (VALUES (MEMBER :on :off))) (check-type row-number (integer 0 *)) (with-slots (separators) table (IF (MEMBER row-number separators) :on :off))) (DEFMETHOD (SETF table-separator) (on-or-off (table table) row-number) (DECLARE (type integer row-number) (VALUES (MEMBER :on :off))) (check-type row-number (integer 0 *)) (with-slots (separators) table (LET ((already-there-p (MEMBER row-number separators))) (ECASE on-or-off (:on (UNLESS already-there-p (PUSH row-number separators) (force-relayout table))) (:off (WHEN already-there-p (SETF separators (DELETE row-number separators)) (force-relayout table)))))) on-or-off) ;;; =========================================================================== ;;; ;;; A Table's Table-Member Method ;;; ;;; =========================================================================== ;;; (DEFMETHOD table-member ((table table) row column) ;; Return NIL if there is no child at position row/column. (DECLARE (VALUES (OR contact NULL))) (LET ((wis (check-for-existing-wis table (contact-width table) (contact-height table) (contact-border-width table)))) (WHEN wis (org-entry-kid (FIND-IF #'(lambda (x) (AND (= (org-entry-row x) row) (= (org-entry-column x) column))) (REST (what-if-organization wis))))))) (DEFMETHOD (SETF table-member) (new-value (table table) row column) ;; What should we do with the child currently at position row/column? ;; Set its constraints to NIL? Set just one of its constraints to NIL? ;; Error if there's one there? I've chosen to blast its constraints. (LET ((existing-child-at-that-position (table-member table row column))) (WHEN existing-child-at-that-position (SETF (table-row existing-child-at-that-position) nil (table-column existing-child-at-that-position) nil)) (SETF (table-row new-value) row) (SETF (table-column new-value) column) (force-relayout table) new-value)) ;;; =========================================================================== ;;; ;;; A Table's Preferred-Size Method ;;; ;;; =========================================================================== ;;; (DEFMETHOD preferred-size ((table table) &key width height border-width) ;; ;; Handle the case where we have no children... ;; (with-slots (children) table (UNLESS children (RETURN-FROM preferred-size (VALUES (+ (display-left-margin table) (display-right-margin table)) (+ (display-top-margin table) (display-bottom-margin table)) (contact-border-width table))))) (with-slots ((old-width width) (old-height height) (old-border-width border-width)) table ;; ;; When the caller specifies no what-if values and we have a good width & height, always ;; return our current values... ;; (WHEN (AND (NULL width) (NULL height) (/= 0 old-width) (/= 0 old-height)) (RETURN-FROM preferred-size (VALUES old-width old-height old-border-width))) ;; ;; We need to what-if. Figure out the width, height, and border-width to use... ;; (SETF width (OR width old-width) height (OR height old-height) border-width (OR border-width old-border-width)) (LET ((wis (check-for-existing-wis table width height border-width))) (UNLESS (AND (what-if-organization wis) (= (what-if-preferred-width wis) width) (= (what-if-preferred-height wis) height)) (place-children-physically table wis nil)) (VALUES (what-if-preferred-width wis) (what-if-preferred-height wis) border-width)))) ;;; =========================================================================== ;;; ;;; A Table's Change-Layout Method ;;; ;;; =========================================================================== ;;; (DEFMETHOD change-layout ((table table) &optional newly-managed) (declare (type (or null contact) newly-managed)) (DECLARE (SPECIAL *called-from-resize-method*)) (with-slots (width height border-width) table ;; Just update the current wis if a single child is being withdrawn... (when (AND newly-managed (EQ (contact-state newly-managed) :withdrawn)) (LET ((wis (check-for-existing-wis table width height border-width))) (WHEN wis (SETF (REST (what-if-organization wis)) (DELETE newly-managed (REST (what-if-organization wis)) :key #'org-entry-kid))))) (LET (p-width p-height (wis (check-for-existing-wis table width height border-width))) ;; With a change in layout we must really re-layout our children... (unless (what-if-in-use wis) (SETF (what-if-in-use wis) t) (place-children-physically table wis t) ;; ;; Update the children's row/column constraints... ;; (DOLIST (o-e (REST (what-if-organization wis))) (SETF (table-row (org-entry-kid o-e)) (org-entry-row o-e) (table-column (org-entry-kid o-e)) (org-entry-column o-e))) (UNLESS (AND (BOUNDP '*called-from-resize-method*) *called-from-resize-method*) (SETF p-width (what-if-preferred-width wis) p-height (what-if-preferred-height wis)) (UNLESS (AND (= height p-height) (= width p-width)) (SETF (what-if-width wis) p-width (what-if-height wis) p-height) (change-geometry table :width p-width :height p-height :accept-p t))) (SETF (what-if-in-use wis) nil))))) ;;; =========================================================================== ;;; ;;; A Table's Resize :after Method ;;; ;;; =========================================================================== ;;; (DEFMETHOD resize :after ((table table) width height b-width) (DECLARE (IGNORE width height b-width)) (LET ((*called-from-resize-method* t)) (DECLARE (SPECIAL *called-from-resize-method*)) (change-layout table))) ;;; =========================================================================== ;;; ;;; A Table's Manage-Geometry Method ;;; ;;; =========================================================================== ;;; ;;; This is not right yet. It should run a what-if to get a Table size for the child's ;;; size change, but this is not possible yet -- the wis doesn't keep all children's ;;; sizes. Then it must call change-geometry to see if its parent will let it be that ;;; size. If so, it should return a thunk that invokes resize, not change-geometry. (defmethod manage-geometry ((table table) child x y width height border-width &key) (values (if (or (and x (/= x (contact-x child))) (and y (/= y (contact-y child))) (and width (/= width (contact-width child))) (and height (/= height (contact-height child))) (and border-width (/= border-width (contact-border-width child)))) #'(lambda (self) (multiple-value-bind (p-w p-h p-b-w) (preferred-size self) (change-geometry self :width p-w :height p-h :border-width p-b-w :accept-p t) (change-layout self) (display-force-output (contact-display self)))) t) (or x (contact-x child)) (or y (contact-y child)) (or width (contact-width child)) (or height (contact-height child)) (or border-width (contact-border-width child)))) ;;; ;;; Internal routines that calculate the width/height of a table, given a What-if-Structure... ;;; Calculate-Preferred-Width ;;; Calculate-Preferred-Height (DEFUN calculate-preferred-width (table wis) (LET* ((ncolumns (what-if-ncolumns wis)) (column-widths (what-if-column-widths wis)) (table-width (+ (display-left-margin table) (display-right-margin table) (* (1- ncolumns) (display-horizontal-space table))))) (DOTIMES (column ncolumns) (INCF table-width (AREF column-widths column 0))) table-width)) (DEFUN calculate-preferred-height (table wis) (with-slots (row-height separators) (THE table table) (LET* ((nrows (what-if-nrows wis)) (organization (what-if-organization wis)) (table-height (+ (display-top-margin table) (display-bottom-margin table) (* (1- nrows) (display-vertical-space table)))) (org-list (REST organization)) (fixed-row-heights row-height) height-for-this-row) (DO ((row 0 (1+ row))) ((= row nrows)) (MULTIPLE-VALUE-SETQ (height-for-this-row fixed-row-heights org-list) (determine-a-rows-height row fixed-row-heights org-list)) (INCF table-height height-for-this-row) ;; Note: The physical size of an OL UI separator (white-space) will be defined ;; to be half the height of the row it follows. A separator placed after ;; the last row will result in extra white-space at the bottom of the table. (WHEN (MEMBER row separators) (INCF table-height (FLOOR (+ height-for-this-row (display-vertical-space table)) 2)))) table-height))) (DEFUN determine-a-rows-height (row fixed-row-heights org-list1) (LET (fixed-height-for-this-row (height-for-this-row 0) found-a-kid-in-this-row-p) (TYPECASE fixed-row-heights (integer (SETF fixed-height-for-this-row fixed-row-heights)) (cons (SETF fixed-height-for-this-row (FIRST fixed-row-heights)) (SETF fixed-row-heights (REST fixed-row-heights)))) (IF fixed-height-for-this-row (SETF height-for-this-row fixed-height-for-this-row) ;;else find the tallest element and the largest border width in this row... (progn (DO ((org-list1 org-list1 (REST org-list1)) kid1 org-entry1 (kid1s-row row)) ((OR (NULL org-list1) (AND found-a-kid-in-this-row-p (/= row kid1s-row)))) (SETF org-entry1 (FIRST org-list1)) (SETF kid1 (org-entry-kid org-entry1) kid1s-row (org-entry-row org-entry1)) (WHEN (= row kid1s-row) (SETF found-a-kid-in-this-row-p t) (SETF height-for-this-row (MAX height-for-this-row (+ (org-entry-height org-entry1) (org-entry-border-width org-entry1) (org-entry-border-width org-entry1)))))))) ;; ;; Because all the members of a row may be withdrawn (and therefore not on the ;; what-if-organization list) it is quite possible to find no children in a row. For now ;; such a row collapses to zero-height... (VALUES height-for-this-row fixed-row-heights org-list1))) ;;; =========================================================================== ;;; ;;; The Guts of Table: Place-Children-Physically ;;; ;;; =========================================================================== ;;; (DEFUN place-children-physically (table wis really-p) (with-slots (children same-width-in-column same-height-in-row columns column-alignment row-alignment column-width row-height separators) (THE table table) (LET (kid last-kid-processed height-for-this-row x1 y1 (fixed-row-heights (UNLESS (EQ row-height :maximum) row-height)) fixed-column-widths width-for-this-column childs-horizontal-size ; Including border-widths. childs-vertical-size ; Including border-widths. max-child-heights-by-row max-child-widths-by-columns org-entry kids-row kids-column y) (UNLESS children (RETURN-FROM place-children-physically)) (CASE columns (:none (put-kids-into-maximum-unaligned-columns table wis really-p) (RETURN-FROM place-children-physically)) (:maximum ;; XtNmaximumColumns. ;; Must scan the kids to figure out what width each column should be. (put-kids-into-maximum-aligned-columns table wis)) (otherwise (UNLESS (INTEGERP columns) (ERROR "~s is not a legal value for :columns" columns)) ;; XtNrequestedColumns. (put-kids-into-specified-number-of-columns table wis))) ;; ;; Position the children on the test sheet per the columnarization... ;; (WHEN really-p (MULTIPLE-VALUE-SETQ (max-child-heights-by-row max-child-widths-by-columns) (scan-for-largest-children wis)) (LET ((org-list (REST (what-if-organization wis))) (column-widths (what-if-column-widths wis))) (SETF y (display-top-margin table)) (CATCH 'out-of-kids (DOTIMES (row (what-if-nrows wis)) (SETF fixed-column-widths (UNLESS (EQ column-width :maximum) column-width)) (MULTIPLE-VALUE-SETQ (height-for-this-row fixed-row-heights) (determine-a-rows-height row fixed-row-heights org-list)) (LET ((fixed-width-for-this-column (AND (INTEGERP fixed-column-widths) fixed-column-widths)) (x (display-left-margin table))) ;; Now set the row's elements' geometries... (DOTIMES (column (what-if-ncolumns wis)) (WHEN (EQ kid last-kid-processed) (SETF org-entry (FIRST org-list)) (WHEN (NULL org-entry) (THROW 'out-of-kids t)) (SETF kid (org-entry-kid org-entry) kids-row (org-entry-row org-entry) kids-column (org-entry-column org-entry))) ;; Figure out what width WE want this column to be... (WHEN (CONSP fixed-column-widths) (SETF fixed-width-for-this-column (FIRST fixed-column-widths))) (SETF width-for-this-column (OR fixed-width-for-this-column (AREF column-widths column 0))) (WHEN (AND (= row kids-row) (= column kids-column)) (SETF childs-horizontal-size (+ (org-entry-width org-entry) (org-entry-border-width org-entry) (org-entry-border-width org-entry)) childs-vertical-size (+ (org-entry-height org-entry) (org-entry-border-width org-entry) (org-entry-border-width org-entry))) (IF (EQ same-width-in-column :on) (SETF childs-horizontal-size width-for-this-column x1 x) ;; else... (SETF childs-horizontal-size (MIN childs-horizontal-size width-for-this-column) x1 (CASE column-alignment (:left x) (:right (+ x (- width-for-this-column childs-horizontal-size))) (:center (+ x (FLOOR (- width-for-this-column childs-horizontal-size) 2)))))) (IF (EQ same-height-in-row :on) (SETF childs-vertical-size height-for-this-row y1 y) ;; else... (SETF childs-vertical-size (MIN childs-vertical-size height-for-this-row) y1 (CASE row-alignment (:top y) (:bottom (+ y (- height-for-this-row childs-vertical-size))) (:center (+ y (FLOOR (- height-for-this-row childs-vertical-size) 2)))))) ;; ;; Reposition and/or resize the child iff needed... ;; (LET ((desired-width (- childs-horizontal-size (org-entry-border-width org-entry) (org-entry-border-width org-entry))) (desired-height (- childs-vertical-size (org-entry-border-width org-entry) (org-entry-border-width org-entry)))) (with-state (kid) (UNLESS (AND (= x1 (contact-x kid)) (= y1 (contact-y kid))) (move kid x1 y1)) (UNLESS (AND (= desired-width (contact-width kid)) (= desired-height (contact-height kid)) (= (org-entry-border-width org-entry) (contact-border-width kid))) (resize kid desired-width desired-height (org-entry-border-width org-entry)))) ;; ;; Done with this child, move on to the next... ;; (SETF org-list (REST org-list)) (SETF last-kid-processed kid))) ;; ;; Whether or not a kid was placed at this row/column, move on to the ;; next column... (INCF x (+ width-for-this-column (display-horizontal-space table))) (WHEN (CONSP fixed-column-widths) (SETF fixed-column-widths (REST fixed-column-widths)))) ;; ;; Get vertical position of top of borders of next row's elements... ;; (INCF y (+ height-for-this-row (display-vertical-space table))) (WHEN (MEMBER row separators) (INCF y (FLOOR (+ height-for-this-row (display-vertical-space table)) 2)))))) )) ;; ;; Having finished placing the kids we can put our preferred size into our wis... ;; (SETF (what-if-preferred-height wis) (calculate-preferred-height table wis) (what-if-preferred-width wis) (calculate-preferred-width table wis)) ))) (DEFUN scan-for-largest-children (wis) (LET* ((max-child-heights-by-row (MAKE-ARRAY (what-if-nrows wis) :initial-element 0)) (max-child-widths-by-column (MAKE-ARRAY (what-if-ncolumns wis) :initial-element 0))) (DOLIST (org-entry (REST (what-if-organization wis))) (LET ((row (org-entry-row org-entry)) (column (org-entry-column org-entry)) (total-child-width (+ (org-entry-width org-entry) (org-entry-border-width org-entry) (org-entry-border-width org-entry))) (total-child-height (+ (org-entry-height org-entry) (org-entry-border-width org-entry) (org-entry-border-width org-entry)))) (SETF (SVREF max-child-heights-by-row row) (MAX (SVREF max-child-heights-by-row row) total-child-height)) (SETF (SVREF max-child-widths-by-column column) (MAX (SVREF max-child-widths-by-column column) total-child-width)))) (VALUES max-child-heights-by-row max-child-widths-by-column))) (DEFUN put-kids-into-specified-number-of-columns (table wis) (DECLARE (VALUES widths-for-columns)) (with-slots (column-width columns children) (THE table table) (LET* (fixed-width-for-this-column total-kid-width (fixed-widths-for-columns column-width)) (SETF (what-if-ncolumns wis) columns (what-if-nrows wis) (CEILING (LENGTH children) columns) (what-if-column-widths wis) (MAKE-ARRAY `(,columns 2) :initial-element 0)) ;; Construct the organization list by assigning the children to specific row/column ;; positions in the Table... (assign-kids-to-rows-and-columns table wis) ;; Ncolumns was specified by the user. Nrows was determined from this and by ;; assign-kids-to-rows-and-columns. This routine scans the organization and builds the array ;; of (list column-width width-of-widest-entry-column) entries. This array is left in the ;; column-widths slot. ;; ;; Find the widest child in each row, set the 2nd element of each width-of-columns ;; entry to the width of the widest child in that column... ;; (DO ((org-list1 (REST (what-if-organization wis)) (REST org-list1)) kid1 org-entry1 kid1s-column kid1s-row) ((NULL org-list1)) (SETF org-entry1 (FIRST org-list1)) (SETF kid1 (org-entry-kid org-entry1) kid1s-row (org-entry-row org-entry1) kid1s-column (org-entry-column org-entry1)) (SETF total-kid-width (+ (org-entry-width org-entry1) (org-entry-border-width org-entry1) (org-entry-border-width org-entry1))) (Setf (AREF (what-if-column-widths wis) kid1s-column 1) (MAX (AREF (what-if-column-widths wis) kid1s-column 1) total-kid-width))) ;; ;; Now go through the columns looking for those with pre-set widths. Use any pre-set ;; width as the column's width, otherwise use the width of the column's widest child. ;; (SETF fixed-widths-for-columns column-width) (DOTIMES (current-column (what-if-ncolumns wis)) ;; Get current-column's fixed width, if any... (SETF fixed-width-for-this-column (TYPECASE fixed-widths-for-columns (integer fixed-widths-for-columns) (CONS (PROG1 (FIRST fixed-widths-for-columns) (SETF fixed-widths-for-columns (REST fixed-widths-for-columns)))))) (SETF (AREF (what-if-column-widths wis) current-column 0) (OR fixed-width-for-this-column (AREF (what-if-column-widths wis) current-column 1))))))) (DEFUN find-first-parents-width (table) (DO ((parent (contact-parent table) (contact-parent parent))) ((NULL parent)) (UNLESS (ZEROP (contact-width parent)) (RETURN (contact-width parent))))) (DEFUN put-kids-into-maximum-unaligned-columns (table wis really-p) (with-slots (children same-width-in-column) (THE table table) (LET* ((org-list (LIST nil)) (working-width (what-if-width wis)) (border-width (what-if-border-width wis))) (WHEN (ZEROP working-width) (SETF working-width (- (find-first-parents-width table) border-width border-width))) ;; Start by sorting the list of children by their row/column constraints. Once this is ;; done we ignore the constraints from here on for :none layout policy... (LET ((nkids (LENGTH children))) (SETF (what-if-nrows wis) nkids (what-if-ncolumns wis) nkids) (assign-kids-to-rows-and-columns table wis)) (LET ((next-x-pos (display-left-margin table)) (next-y-pos (display-top-margin table)) (largest-height-this-row 0) (columns-this-row 0) (ncolumns-in-table 0) (nrows-in-table 0) (preferred-width-of-table 0)) (FLET ((handle-the-end-of-a-row () (SETF ncolumns-in-table (MAX ncolumns-in-table columns-this-row)) (SETF preferred-width-of-table (MAX preferred-width-of-table (+ next-x-pos (- (display-right-margin table) (display-horizontal-space table))))) (SETF next-x-pos (display-left-margin table)) (INCF nrows-in-table) (INCF next-y-pos (+ largest-height-this-row (display-vertical-space table))) (SETF columns-this-row 0 largest-height-this-row 0)) ) (DOLIST (child children) (UNLESS (EQ (contact-state child) :withdrawn) (MULTIPLE-VALUE-BIND (childs-p-width childs-p-height childs-p-border-width) (preferred-size child) (LET ((childs-total-width (+ childs-p-width (* 2 childs-p-border-width))) (childs-total-height (+ childs-p-height (* 2 childs-p-border-width)))) ;; ;; If cannot place this child at the end of this row, finish off this row and move ;; on to the next row... ;; (WHEN (< (- working-width next-x-pos (display-right-margin table)) childs-total-width) (handle-the-end-of-a-row)) ;; ;; Position this child where we've decided it should go... ;; (WHEN really-p (with-state (child) (UNLESS (AND (= next-x-pos (contact-x child)) (= next-y-pos (contact-y child))) (move child next-x-pos next-y-pos)) (UNLESS (AND (= childs-p-width (contact-width child)) (= childs-p-height (contact-height child)) (= childs-p-border-width (contact-border-width child))) (resize child childs-p-width childs-p-height childs-p-border-width)))) ;; ;; Done with this child, move on to the next child and the next position in this ;; row... ;; (PUSH (make-org-entry :kid child :row nrows-in-table :column columns-this-row :width childs-p-width :height childs-p-height :border-width childs-p-border-width) org-list) (INCF next-x-pos (+ childs-total-width (display-horizontal-space table))) (SETF largest-height-this-row (MAX largest-height-this-row childs-total-height)) (INCF columns-this-row))))) ;; ;; Set into the what-if structure the height, width, and organization just calculated... ;; (handle-the-end-of-a-row) (SETF (what-if-nrows wis) nrows-in-table) (SETF (what-if-ncolumns wis) ncolumns-in-table) (SETF (what-if-preferred-height wis) (+ next-y-pos (- (display-vertical-space table)) (display-bottom-margin table))) (SETF (what-if-preferred-width wis) preferred-width-of-table) (SETF (what-if-organization wis) (NREVERSE org-list)) ;; ;; Set up a fake column-widths array for others... ;; (SETF (what-if-column-widths wis) (MAKE-ARRAY `(,ncolumns-in-table 2) :initial-element 0)) (SETF (AREF (what-if-column-widths wis) 0 0) (what-if-preferred-width wis))))))) (DEFUN put-kids-into-maximum-aligned-columns (table wis) ;; This is a guessing procedure that implements the XtNmaximumColumns policy for row and column ;; layout. Keep an array of items (column-width max-width-of-columns-items). Create and ;; initialize it from the 1st child: identical column widths = 1st child's preferred width, ;; max-width-of-columns-items = 0. Set NROWS to 0. Then start trying to place the children ;; into these columns. The 1st child will fit for sure, updating the 1st column's max-width. ;; The 2nd-Nth children may or may not fit. If it does, update max-width. If not, see if ;; other columns' can be made narrower to allow this column to be made wide enough for him to ;; fit. If so, do it. If not, we must reduce the number of columns by one, assigning them ;; equal widths, then start the layout process from the top. Each time we try to place a child ;; in the first column, increment NROWS. ;; Note that while this routine tends to give about the same amount of space to each column, ;; the slack space for the columns may differ considerably. After we find a child the cannot ;; fit in a column and reduce the number of columns to get more space, we give each column the ;; same, new, enlarged space. If one column is actually fairly narrow and doesn't need more ;; space it'll end up with extra slack space around it. A slack-space-smoothing routine should ;; be written to improve this. (DECLARE (VALUES nrows ncolumns column-widths)) (with-slots (children column-width) (THE table table) (LET ((nkids (LENGTH children)) (working-width (what-if-width wis)) (working-border-width (what-if-border-width wis))) (WHEN (<= working-width 0) (SETF working-width (- (find-first-parents-width table) working-border-width working-border-width))) ;; ;; Start by sorting the list of children by their row/column constraints. Once this is ;; done we ignore the constraints from here on for :maximum layout policy... ;; (SETF (what-if-nrows wis) nkids (what-if-ncolumns wis) nkids) (assign-kids-to-rows-and-columns table wis) ;; Start with an upper bound on the number of columns... (LET* ((ncolumns (MIN nkids (get-maximum-possible-ncolumns table working-width))) (column-widths (MAKE-ARRAY `(,ncolumns 2))) (column-widths-vector (MAKE-ARRAY (* 2 ncolumns) :displaced-to column-widths))) ;; ;; Each execution of this outer loop represents an attempt at fitting the children ;; into a given number of columns. The inner loop below does the actual laying out of ;; the children; if it succeeds, it sets FINISHED to T as it exits. If it fails, it ;; decrements NCOLUMNS and leaves FINISHED NIL. ;; (DO* (finished (org-list (LIST nil)) (org-tail org-list) next-row next-column) (finished ;; ;; Make each column's real width equal to the widest child we've placed in it, ;; adjust ncolumns by the number of unused columns... ;; (DOTIMES (column ncolumns) (IF (ZEROP (AREF column-widths column 1)) (DECF ncolumns) (SETF (AREF column-widths column 0) (AREF column-widths column 1)))) (SETF (what-if-column-widths wis) column-widths) (SETF (what-if-ncolumns wis) ncolumns) (SETF (what-if-organization wis) org-list) (SETF (what-if-nrows wis) (1+ next-row))) ;; Initialize the first ncolumns elements of the column-widths array... ;; Total horizontal space available for the columns: ;; width - right-margin - left-margin - (n - 1)*horizontal-space. ;; This total is divided into ncolumns equal chunks, with any extra white space ;; being given a pixel at a time to the left-most columns. ;; But not quite. We need to handle fixed-width columns specially. At this point ;; we know how many columns we're (tentatively) giving the table, call it N. We ;; need to see how much of our space is occupied by fixed-width columns in the ;; first N columns and how many there are, call it M. The remaining N-M columns ;; each gets 1/(N-M) of the remaining space. Be careful abaout N=M! And each ;; fixed-width column gets *both* of its column-width entries initialized here to ;; its fixed width so it'll look like there's no slack in that column (which there ;; isn't). Unlike a variable-width column, a fixed-width column never gets its ;; 2nd column-widths entry changed as we place kids in it. (LET ((total-fixed-width 0) (n-fixed-width-columns 0) (fixed-column-widths (UNLESS (EQ column-width :maximum) column-width))) ;; Forget the column widths calculated last time through the loop... (FILL (THE vector column-widths-vector) nil) ;; Calculate how much of the total table width is allocated to fixed-width ;; columns... (COND ((NULL fixed-column-widths)) ((INTEGERP fixed-column-widths) (SETF total-fixed-width (* ncolumns fixed-column-widths) n-fixed-width-columns ncolumns) (DOTIMES (column-number ncolumns) (SETF (AREF column-widths column-number 0) (SETF (AREF column-widths column-number 1) fixed-column-widths)))) ((CONSP fixed-column-widths) (DO ((fixed-column-widths fixed-column-widths (REST fixed-column-widths)) (column-number 0 (1+ column-number)) fixed-width) ((OR (= column-number ncolumns) (ENDP fixed-column-widths))) (SETF fixed-width (FIRST fixed-column-widths)) (WHEN fixed-width (INCF n-fixed-width-columns) (INCF total-fixed-width fixed-width) (SETF (AREF column-widths column-number 0) (SETF (AREF column-widths column-number 1) fixed-width))))) (t (ERROR "column-width is ~a." fixed-column-widths))) ;; Now n-fixed-width-columns = # of fixed width columns in first ncolumns ;; total-fixed-width = # of pixels occupied by those columns ;; and for each fixed-width column both column-widths entries = the fixed width. ;; Take the remaining space and give it to the non-fixed-width columns... (UNLESS (ZEROP (- ncolumns n-fixed-width-columns)) (MULTIPLE-VALUE-BIND (horizontal-space-for-each-var-column extra-white-space) (FLOOR (- working-width (display-left-margin table) (display-right-margin table) (* (1- ncolumns) (display-horizontal-space table)) total-fixed-width) (- ncolumns n-fixed-width-columns)) ;; Assign the non-fixed-width space to the non-fixed-width columns. Because ;; we FILL column-widths with NIL each time through the main loop, only ;; fixed-width columns will have none-NIL values in them. Give the extra ;; white-space to the left-most variable-width columns a pixel at a time. (DOTIMES (i ncolumns) (WHEN (NULL (AREF column-widths i 0)) (SETF (AREF column-widths i 0) (+ horizontal-space-for-each-var-column (IF (ZEROP extra-white-space) 0 (PROGN (DECF extra-white-space) 1)))) (SETF (AREF column-widths i 1) 0))))) (SETF org-list (LIST nil) org-tail org-list next-row -1 next-column (1- ncolumns)) ;; ;; Try to lay the children into the columns sized as they are now... ;; (DOLIST (child children (SETF finished t)) (UNLESS (EQ (contact-state child) :withdrawn) ;; ;; If the column this child's to go in is beyond ncolumns, wrap to the first ;; column of the next row... ;; (INCF next-column) (WHEN (= next-column ncolumns) (SETF next-column 0) (INCF next-row) (SETF fixed-column-widths (UNLESS (EQ column-width :maximum) column-width))) (LET* ((columns-width-right-now (AREF column-widths next-column 0)) (fixed-width-for-this-column (IF (LISTP fixed-column-widths) ;; ERCM (FIRST fixed-column-widths) fixed-column-widths))) (UNLESS fixed-width-for-this-column ;; Find out what width the child thinks he should be... (MULTIPLE-VALUE-BIND (childs-width childs-height childs-border-width) (preferred-size child :width columns-width-right-now) (DECLARE (IGNORE childs-height)) ;; Calculate how much horizontal space this child needs... (LET ((horizontal-space-for-this-child (+ childs-width childs-border-width childs-border-width))) (COND ((OR (<= horizontal-space-for-this-child columns-width-right-now) (adjust-column-widths-so-child-fits column-widths horizontal-space-for-this-child next-column ncolumns)) (SETF (AREF column-widths next-column 1) (MAX (AREF column-widths next-column 1) horizontal-space-for-this-child))) (t ;; else child can't fit in this column. Reduce the number of ;; columns and try again. (DECF ncolumns) (RETURN nil))))))) ;; To get here we must have decided we can successfully place this kid at ;; this position, so add an entry for it onto the org-list... (SETF (REST org-tail) (LIST (establish-org-entry child next-row next-column))) (SETF org-tail (REST org-tail)) ;; Advance to the next column's entry in the fixed-width list if there is ;; one... (WHEN (CONSP fixed-column-widths) (SETF fixed-column-widths (REST fixed-column-widths))))))))))) (DEFUN adjust-column-widths-so-child-fits (column-widths childs-width next-column ncolumns) (DO ((npixels-needed (- childs-width (AREF column-widths next-column 0)))) ((ZEROP npixels-needed) (SETF (AREF column-widths next-column 0) childs-width) t) ;; Find column with greatest slack, if any... (LET ((max-slack 0) (max-slack-col nil)) (DOTIMES (col ncolumns) (UNLESS (= next-column col) ; Don't look at column child goes in (LET ((slack (- (AREF column-widths col 0) (AREF column-widths col 1)))) (WHEN (> slack max-slack) (SETF max-slack slack max-slack-col col))))) ;; If no column had any slack, return NIL... (UNLESS max-slack-col (RETURN nil)) ;; Otherwise take a pixel from the max-slack-col's width, reduce our goal by one, try ;; again... (DECF (AREF column-widths max-slack-col 0)) (DECF npixels-needed)))) (DEFUN get-maximum-possible-ncolumns (table width) "Returns the maximum number of columns possible given the specified constraints." (with-slots (children column-width) (THE table table) (LET* ((fixed-column-widths (UNLESS (EQ column-width :maximum) column-width)) (minimum-column-width (- width (display-left-margin table) (display-right-margin table)))) ;; ;; If the caller specified a single fixed width for all columns, then that's it... ;; (IF (INTEGERP fixed-column-widths) (SETF minimum-column-width (MIN minimum-column-width fixed-column-widths)) ;; else... (PROGN ;; ;; If the caller specified a list of fixed widths (and nil's) for (some of) the ;; columns, first find the minimum of these fixed column widths... ;; (WHEN (CONSP fixed-column-widths) (DOLIST (this-fixed-column-width fixed-column-widths) (WHEN this-fixed-column-width (SETF minimum-column-width (MIN minimum-column-width this-fixed-column-width))))) ;; ;; Then as a crude approximation, find the narrowest child, not knowing what column ;; the child will go in... ;; (DOLIST (kid children) (UNLESS (EQ (contact-state kid) :withdrawn) (MULTIPLE-VALUE-BIND (preferred-width preferred-height preferred-border-width) (preferred-size kid) (DECLARE (IGNORE preferred-height)) (SETF minimum-column-width (MIN minimum-column-width (+ preferred-width preferred-border-width preferred-border-width)))))))) ;; Now that we have the smallest column width we could ever get, calculate and return the ;; maximum number of columns we could ever have... (MIN (LENGTH children) (FLOOR (+ (- width (display-left-margin table) (display-right-margin table)) (display-horizontal-space table)) (+ minimum-column-width (display-horizontal-space table))))))) ;;; ;;; These routines construct the ORGANIZATION list by placing each child at a specific ;;; row/column position ;;; ;;;. Lexical variables: ;;; hole-pointer where in the existing organization list to rplacd-in an entry for an ;;; unconstrained child -- the current "hole". All entries in the ;;; organization list preceding this one are contiguous starting from row 0, ;;; column 0, so all attempts at child placement, regardless of the ;;; constraints, start from here. Hole-row & hole-column are one row/col ;;; position beyond the row/col of (FIRST hole-pointer), unless (first ;;; hole-pointer) is NIL, in which case they are (0,0). ;;; hole-row the row-number of the current hole. ;;; hole-column the column-number of the current hole. ;;; ncolumns the number of columns in the table. Fixed. ;;; nrows the number of rows in the table. Can change if a child specifies a big ;;; row-constraint. ;;; (DEFUN assign-kids-to-rows-and-columns (table wis) (LET (hole-pointer hole-row hole-column ncolumns nrows) (DECLARE (inline insert-into-organization-list)) (LABELS ( ;; ;; Makes sure the hole-pointer/row/column actually point at a hole. If they currently ;; point at an allocated table row/column, moves them over until they point at an ;; unallocated one. ;; (find-next-hole () (DO* (org-entry org-row org-column (org-list hole-pointer)) (nil) ;; ;; Look at the next org-entry, the one just beyond the hole pointer. The second - ;; Nth times through the loop this also advances the hole-pointer... ;; (SETF hole-pointer org-list org-list (REST org-list)) (WHEN org-list (SETF org-entry (FIRST org-list) org-row (org-entry-row org-entry) org-column (org-entry-column org-entry))) (WHEN (OR (NULL org-list) ; Exhausted org-list. Leave hole pointing at ; row/col one beyond the last org-entry. (/= org-row hole-row) ; There's space between the previous org-entry (/= org-column hole-column)) ; and this one. Leave hole pointing ; at row/col one beyond the previous ; org-entry. (RETURN)) ;; ;; The row/column position of the hole is occupied. Move the row/column of the hole ;; over one position, try again... ;; (WHEN (= (INCF hole-column) ncolumns) (INCF hole-row) (SETF hole-column 0)))) ;; ;; Insert KID into the organization list at INSERTION-POINT at ROW/COLUMN... ;; (insert-into-organization-list (kid insertion-point row column) (RPLACD insertion-point (CONS (establish-org-entry kid row column) (REST insertion-point))) (find-next-hole) (WHEN (>= row nrows) ; Update nrows if necessary. (SETF nrows (1+ row)))) ; * ;; ;; Inserts a kid with no constraints in the next hole, moves the hole pointers. Always ;; successful, so always returns T. ;; (place-a-kid-at-any-row-and-column (kid) (insert-into-organization-list kid hole-pointer hole-row hole-column) t) ;; ;; Tries to insert a kid into a specific row/column, returning T if successful, NIL if ;; not. Fails if that row/column is already occupied or specified column is outside ;; ncolumns. ;; (place-a-kid-at-a-specific-row-and-column (kid kid-row kid-column) (LET ((kid-position (+ (* ncolumns kid-row) kid-column)) (last-occupied-position (IF (FIRST hole-pointer) (+ (* ncolumns (org-entry-row (FIRST hole-pointer))) (org-entry-column (FIRST hole-pointer))) -1))) (WHEN (OR (>= kid-column ncolumns) (>= last-occupied-position kid-position)) (RETURN-FROM place-a-kid-at-a-specific-row-and-column nil)) (DO ((org-list hole-pointer) insertion-point org-position) (nil) (SETF insertion-point org-list org-list (REST org-list)) (SETF org-position (IF org-list (+ (* ncolumns (org-entry-row (FIRST org-list))) (org-entry-column (FIRST org-list))) (1+ kid-position))) (COND ((= org-position kid-position) ; Kid's row/column occupied: failure. (RETURN-FROM place-a-kid-at-a-specific-row-and-column nil)) ((> org-position kid-position) ; Kid's row/column free: success. (insert-into-organization-list kid insertion-point kid-row kid-column) (RETURN-FROM place-a-kid-at-a-specific-row-and-column t)) (t nil))))) ;; ;; Tries to insert a kid into a specific row. ;; Fails if row is full, returns NIL, otherwise is successful, returns T. ;; (place-a-kid-in-a-specific-row (kid kid-row) (WHEN (< kid-row hole-row) (RETURN-FROM place-a-kid-in-a-specific-row nil)) (DO ((org-list hole-pointer) insertion-point (last-occupied-column (IF (FIRST hole-pointer) (org-entry-column (FIRST hole-pointer)) -1) org-column) org-entry (org-row kid-row) org-column) ((OR (NULL org-list) (> org-row kid-row)) ;; Failure -- exit here iff couldn't insert child nil) (SETF insertion-point org-list org-list (REST org-list)) (IF org-list (SETF org-entry (FIRST org-list) org-row (org-entry-row org-entry) org-column (org-entry-column org-entry)) ;; else no more org-entries so fake one way out there... (SETF org-row (1+ kid-row))) (WHEN (OR (AND (= org-row kid-row) ; In kid's row and there's a hole. (< (1+ last-occupied-column) ; * org-column)) ; * (AND (> org-row kid-row) ; First org-entry beyond kid's row (< last-occupied-column ; and there's a hole at the end (1- ncolumns)))) ; of the kid's row. (insert-into-organization-list kid insertion-point kid-row (1+ last-occupied-column)) (RETURN-FROM place-a-kid-in-a-specific-row t)))) ;; ;; Inserts a kid into a specific column. ;; Fails if column is not within ncolumns, returns NIL, otherwise always successful, ;; returns T. ;; (place-a-kid-in-a-specific-column (kid kids-column) (WHEN (>= kids-column ncolumns) (RETURN-FROM place-a-kid-in-a-specific-column nil)) (DO* ((org-list hole-pointer) insertion-point (last-org-position -1 org-position) org-position (insertion-row (IF (< kids-column hole-column) (1+ hole-row) hole-row)) (position-of-next-occurrence-of-kids-column (+ (* ncolumns insertion-row) kids-column))) (nil) (SETF insertion-point org-list org-list (REST org-list)) (SETF org-position (IF org-list (+ (* ncolumns (org-entry-row (FIRST org-list))) (org-entry-column (FIRST org-list))) (1+ position-of-next-occurrence-of-kids-column))) (WHEN (< last-org-position position-of-next-occurrence-of-kids-column org-position) (insert-into-organization-list kid insertion-point insertion-row kids-column) (RETURN-FROM place-a-kid-in-a-specific-column t)) ;; Calculate a new position-of-next-occurrence-of-kids-column if this org-entry is at ;; or beyond the current value... (WHEN (>= org-position position-of-next-occurrence-of-kids-column) (INCF position-of-next-occurrence-of-kids-column ncolumns) (INCF insertion-row)))) ;; ;; This is called by assign-kids-to-rows-and-columns when it realizes it is dealing with ;; a :maximum or :none table. The Table's children list is rebuilt to be ;; the (already sorted) kids in the org-list followed by the kids in the free-list. ;; Where unconstrained kids would normally be used to fill in holes in a ;; fixed-number-of-columns table, there really are no holes for a :maximum or ;; :none table so such children are just placed at the end of the Table's ;; children list. ;; (build-sorted-list-of-children (table org-list free-list withdrawn-children) (with-slots (children) (THE table table) (LET* ((sorted-children-list (MAKE-LIST (LENGTH org-list))) ; includes leading NIL. (next-sorted-children-list sorted-children-list) (last-sorted-children-list sorted-children-list)) (DOLIST (org-entry (REST org-list)) (SETF last-sorted-children-list next-sorted-children-list next-sorted-children-list (REST next-sorted-children-list)) (RPLACA next-sorted-children-list (org-entry-kid org-entry))) (WHEN free-list (RPLACD last-sorted-children-list (NCONC free-list withdrawn-children))) (SETF children (REST sorted-children-list))))) ) ; ...end of labels... ;; ==================================================================================== ;; The code for assign-kids-to-rows-and-columns (table wis): ;; Constructs the what-if-organization list by assigning each kid to a specific ;; row/column position in the table. ;; (with-slots (children) (THE table table) (LET (free-row free-col free (old-org-list (REST (what-if-organization wis))) withdrawn-children) (SETF (what-if-organization wis) (LIST nil) hole-pointer (what-if-organization wis) hole-row 0 hole-column 0 ncolumns (what-if-ncolumns wis) nrows (what-if-nrows wis)) ;; First try to place all the kids with definite row/column constraints. ;; Any child specifying only a row goes on the free-col list. ;; Any child specifying only a column goes on the free-row list. ;; Any child specifying neither row nor column, or any child unable to be placed where ;; its definite row/column constraints placed it, goes on the free list. (DOLIST (kid children) (COND ((NOT (EQ (contact-state kid) :withdrawn)) (UNLESS (OR (NULL old-org-list) (EQ kid (org-entry-kid (FIRST old-org-list)))) (CERROR "continue" "children and org-list don't match")) (LET ((row (OR (table-row kid) (AND old-org-list (org-entry-row (FIRST old-org-list))))) (column (OR (table-column kid) (AND old-org-list (org-entry-column (FIRST old-org-list)))))) (SETF old-org-list (REST old-org-list)) (COND ((AND row column) (UNLESS (place-a-kid-at-a-specific-row-and-column kid row column) (PUSH kid free))) (row (PUSH `(,kid ,row) free-col)) (column (PUSH `(,kid ,column) free-row)) (t (PUSH kid free))))) (t (PUSH kid withdrawn-children)))) ;; Now try to place all the kids specifying only a column. Since it is always OK to ;; create a new row, such kids can always be placed... (DOLIST (kid-and-column (NREVERSE free-row)) (place-a-kid-in-a-specific-column (FIRST kid-and-column) (SECOND kid-and-column))) ;; Now try to place all the kids specifying only a row. If that row is full, place ;; the child on the free list... (DOLIST (kid-and-row (NREVERSE free-col)) (UNLESS (place-a-kid-in-a-specific-row (FIRST kid-and-row) (SECOND kid-and-row)) (PUSH (FIRST kid-and-row) free))) ;; Finally, place the kids that are on the free list. These kids have no constraints, ;; so they'll all be placed in holes scanning from top-left to bottom-right or new ;; rows will be created to hold them... (IF (SYMBOLP (table-columns table)) (build-sorted-list-of-children table (what-if-organization wis) (NREVERSE free) withdrawn-children) ;; else... (PROGN (DOLIST (kid (NREVERSE free)) (place-a-kid-at-any-row-and-column kid)) ;; ;; Rebuild the children list in the order of the what-if-organization ;; followed by any :withdrawn children not on the what-if-organization list. ;; (DO ((children children (REST children)) (organization (REST (what-if-organization wis)) (REST organization))) ((NULL organization) (DOLIST (withdrawn-child withdrawn-children) (RPLACA children withdrawn-child) (SETF children (REST children)))) (RPLACA children (org-entry-kid (FIRST organization)))))) (SETF (what-if-nrows wis) nrows)))))) ;; This is called by assign-kids-to-rows-and-columns when it realizes it is dealing with a ;; :maximum or :none table. The Table's children list is rebuilt to be the ;; (already sorted) kids in the org-list followed by the kids in the free-list. Where ;; unconstrained kids would normally be used to fill in holes in a fixed-number-of-columns ;; table, there really are no holes for a :maximum or :none table so such children ;; are just placed at the end of the Table's children list. (DEFUN build-sorted-list-of-children (table org-list free-list withdrawn-children) (with-slots (children) (THE table table) (LET* ((sorted-children-list (MAKE-LIST (LENGTH org-list))) ; includes leading NIL. (next-sorted-children-list sorted-children-list) (last-sorted-children-list sorted-children-list)) (DOLIST (org-entry (REST org-list)) (SETF last-sorted-children-list next-sorted-children-list next-sorted-children-list (REST next-sorted-children-list)) (RPLACA next-sorted-children-list (org-entry-kid org-entry))) (WHEN free-list (RPLACD last-sorted-children-list (NCONC free-list withdrawn-children))) (SETF children (REST sorted-children-list)))))